perm filename SETLET.F4[MSS,LCS]1 blob
sn#075932 filedate 1974-03-19 generic text, type T, neo UTF8
00001 C SUBRS. SETLET, SETNUM
00002
00010 SUBROUTINE SETLET
00015 DIMENSION RPOS(2,40),R(8,100)
00020 COMMON/SCM/V(78),Y,LCNT,STAFF,JLIST(200),REND
00030 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
00053 COMMON/PTR/PWDS(250),ITEM,L,I,IX /XRN/RN(4000)
00090 COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
00095 EQUIVALENCE(RPOS,RN(3921)),(JF,JQ(4)),(R,RN(3001))
00100 M=1
00110 RPOS(1,1)=0
00200 DO 1 K=1,ITEM
00400 IF(FINDIT(K))GO TO 1
00500 C SKIPS NON-NOTES AND WRONG STAFF
00600 M=M+1
00700 RPOS(1,M)=RN(L+2)
00800 CC RPOS(2,M)=L
00900 1 CONTINUE
00905 CALL SETNUM
01000 CALL SORT2(RPOS,M)
01010 K=2
01020 22 IF(RPOS(1,K).NE.RPOS(1,K-1))GO TO 2
01025 M=M-1
01030 DO 20 J=K,M
01040 20 RPOS(1,J)=RPOS(1,J+1)
01045 C DELETES DOUBLE-STOPS - DOESN'T PUT NUM OVER 1ST NOTE.
01047 GO TO 22
01055 2 K=K+1
01057 IF(K.LT.M)GO TO 22
01103 DO 4 K=2,M
01150 JB=RHORZ(RPOS(1,K))
01200 CALL NOTWRT
01210 JF=JF+1
01220 4 IF(JF.EQ.10)JF=0
01330 CALL DPYOUT(3)
01340 CALL SETPOG(1)
01360 RPOS(1,M+1)=200
01370 J=1
01380 CALL TYPE
01390 REREAD F78F,V
01400 X=V(J)+1
01500 M=1
01600 3 K=X
01700 A=RPOS(1,K)
01800 B=RPOS(1,K+1)
01900 R(2,M)=A+(B-A)*(X-K)
01910 IF(R(4,M).NE.0)GO TO 5
02000 R(4,M)=V(J+1)
02100 J=J+2
02110 GO TO 6
02115 C IF P4≠0 TYPE ONLY 1 # FOR EACH ITEM. ALL ITEMS WILL BE AT VRT PS OF P4
02117 C TYPE Nn, Vert pos/Nn, Vert pos/ OR Nn/Nn/ (if P4≠0)
02120 5 J=J+1
02180 6 M=M+1
02200 X=V(J)+1
02300 IF(X.GT.1)GO TO 3
02350 C CAN'T PUT LETTER AT POS. 0 *********
02400 END
02410
02420 SUBROUTINE SETNUM
02520 DIMENSION SU(320)
02540 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
02550 COMMON/POSI/STF(8),JJB,POS/DPY/ST(4000),WDS(250),MEDIT,IGO
02570 EQUIVALENCE (JC,JQ(1)),(JF,JQ(4)),(RJE,RJQ(3)),(RJD,RJQ(2))
02580 1,(SU(1),ST(3600))
02590 CALL DPYSET(3,SU,320)
02600 CALL DPYBRT(6)
02610 JF=1
02620 CC RA=ST(1)
02630 CC RJD=R(3,1)
02640 POS=STF(JC+4)
02650 RJD=18.
02660 JA=5
02670 RJE=1
02680 END